
open Common

type mpfi 

external initialize : int -> unit = "mpfi_initialize_"
  (** 
      [initialize pool_size] must be called before any interval 
      manipulations.  This should not be exported by the top level
      interface module {!Mpfi}, but rather that module should call
      this function.  

   *)

let _ = initialize 1000

external debug : bool -> unit = "debug_"
external used_locations : unit -> int = "used_locations_"
external allocated_locations : unit -> int = "allocated_locations_"
external set_gc_used : int -> unit = "set_gc_used_"
external set_gc_max : int -> unit = "set_gc_max_"

let set_gc_values ~used ~max = 
  (set_gc_used used;
   set_gc_max max)

external of_string_ : string -> mpfi = "of_string_"
let of_string s = of_string_ ("[" ^ s ^ "," ^ s ^ "]")

external add   : mpfi -> mpfi -> mpfi = "add_"
external sub   : mpfi -> mpfi -> mpfi = "sub_"
external mul   : mpfi -> mpfi -> mpfi = "mul_"
external div   : mpfi -> mpfi -> mpfi = "div_"
external union : mpfi -> mpfi -> mpfi = "union_"

external cmp_       : mpfi -> mpfi -> int = "cmp_"
external is_inside_ : mpfi -> mpfi -> int = "is_inside_"

let is_inside x y = is_inside_ x y > 0

external neg  : mpfi -> mpfi = "neg_"
external inv  : mpfi -> mpfi = "inv_"
external sqr  : mpfi -> mpfi = "sqr_"
external sqrt : mpfi -> mpfi = "sqrt_"
external abs  : mpfi -> mpfi = "abs_"
external log  : mpfi -> mpfi = "log_"
external sin  : mpfi -> mpfi = "sin_"
external cos  : mpfi -> mpfi = "cos_"
external tan  : mpfi -> mpfi = "tan_"
external asin : mpfi -> mpfi = "asin_"
external acos : mpfi -> mpfi = "acos_"
external atan : mpfi -> mpfi = "atan_"

external icenter : mpfi -> mpfi = "icenter_"
external iwidth  : mpfi -> mpfi = "iwidth_"
external ilower  : mpfi -> mpfi = "ilower_"
external iupper  : mpfi -> mpfi = "iupper_"

external bisect : mpfi -> mpfi * mpfi = "bisect_"

external has_zero        : mpfi -> bool = "has_zero_"
external nan_p           : mpfi -> bool = "nan_p_"
external inf_p           : mpfi -> bool = "inf_p_"
external bounded_p       : mpfi -> bool = "bounded_p_"
external is_empty        : mpfi -> bool = "is_empty_"
external is_strictly_pos : mpfi -> bool = "is_strictly_pos_"

external width : mpfi -> float = "width_"
external center : mpfi -> float = "center_"
external lower : mpfi -> float = "lower_"
external upper : mpfi -> float = "upper_"

external mem : mpfi -> float -> bool = "mem_"

external pi_ : unit -> mpfi = "pi_"
let pi = pi_()


(** Note that the MPFI documentation is incorrect.
    the return value of mpfi_cmp is negative if the 
    first interval is completely less than the second. *)
let lt x y = 
  if nan_p x || nan_p y then None else
  let n = cmp_ x y in
    if n < 0 then Some true
    else if n > 0 then Some false
    else None

let is_zero x = width x = 0.0 && mem x 0.0

(* -------------------------------------------------------------------------- *)
(*  Parsing and Printing                                                      *)
(* -------------------------------------------------------------------------- *)

module S = String
module P = Parse
open P
open P.Ops

type ep = Nan
        | Inf
        | NegInf
        | Reg of ((bool * string) * (bool * string))

let rec lex inp =
  let _,inp1 = lexwhile space inp in
  match inp1 with
    [] -> []
  | c::cs -> let prop =
               if numeric(c) then numeric
               else if alpha(c) then alpha
               else if symbolic(c) then symbolic
               else if punctuation(c) then (fun c -> false)
               else failwith "Unknown character in input" in
             let toktl,rest = lexwhile prop cs in
             (c^toktl)::lex rest;;

let make_parser pfn s =
  let expr,rest = pfn (lex(explode s)) in
  if rest = [] then expr else failwith "Unparsed input";;

let mk_num ((msgn,m),(esgn,e)) = 
  let ms = if msgn then "-" else "" in
  let es = if esgn then "-" else "" in
    ms ^ "." ^ m ^ " E" ^ es ^ e

let mk_num' m = match m with
  | Reg x -> mk_num x
  | Nan -> "NaN"
  | Inf -> "oo"
  | NegInf -> "-oo"
    
let parse_num = maybe (a "-") ++ next ++ a "E" ++ maybe (a "-") ++ next
  >> (fun ((((sgno,n),_),esgno),m) -> Reg((is_some sgno,n),(is_some esgno,m)))

let parse_nan = a "@" ++ a "NaN" ++ a "@"  >> 
  (fun _ -> Nan)

let parse_inf = a "@" ++ a "Inf" ++ a "@" >> 
  (fun _ -> Inf)

let parse_neginf = a "-@" ++ a "Inf" ++ a "@" >> 
  (fun _ -> NegInf)

let parse_ep = parse_num || parse_nan || parse_inf || parse_neginf

let parse_ival = a "[" ++ parse_ep ++ a "," ++ parse_ep ++ a "]" 
  >> (fun ((((_,n),_),m),_) -> n,m)

let parse = make_parser parse_ival

(* 
let s =  "[-31415000000000002E-1,31415000000000002E-1]"
let s = "[99999999999999992E-1,10000000000000001E0]"
parse s
lex (explode s)
let s = "[@Inf@E0,@Inf@E0]"
*) 

external to_string_ : mpfi -> string = "to_string_"

let raw_string = to_string_

let to_string ival = 
  let s = to_string_ ival in
  let x,y = parse s in
  let xs,ys = mk_num' x, mk_num' y in
    "[" ^ xs ^ "," ^ ys ^ "]"

let print = print_stringl ** to_string




